home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 26
/
Cream of the Crop 26.iso
/
program
/
qbasix.zip
/
QBASIX.PRO
< prev
Wrap
Text File
|
1994-05-08
|
15KB
|
520 lines
'******************************************************************************
'* QBASIX - assembler routines for QBASIC - version 2 *
'* The QBASIX procedures *
'* (c) Hans Lunsing - 04/1994 *
'******************************************************************************
'This file holds the QBASIX procedures together with their types and
'constants. You can insert them in your own programs as needed. Don't
'forget to copy the routines called by them and the declarations going
'with them also.
'If you use procedures calling the QBASIX library QBASIX.EXE you have
'to build your program inside the shell required for using the library.
'This shell checks the existence of QBASIX and passes its position in
'memory to the program. You will find it in the file QBASIX.BAS. You can
'simply add your own program code with its declarations and procedures
'to it at the indicated positions.
DEFINT A-Z
' Type for storing video information
TYPE VideoType
'Is necessary for use of SUB GetVideoInfo
Mode AS INTEGER 'video mode
Rows AS INTEGER 'number of rows
Cols AS INTEGER 'number of columns
Page AS INTEGER 'active screen page
Offs AS INTEGER 'offset of the same in video memory
Segment AS INTEGER 'segment of the same
CRT AS INTEGER 'adapter: MDA = 1, CGA = 2, EGA = 3,
'MCGA = 4, VGA = 5, HERC = 11,
'OTHER = 0
Colour AS INTEGER '-1 if color screen,
'0 if monochrome screen
Port AS INTEGER 'port number of video controller
END TYPE
' Registertype to use with INTERRUPTX and MSDOS
TYPE RegTypeX
AX AS INTEGER
BX AS INTEGER
CX AS INTEGER
DX AS INTEGER
bp AS INTEGER
si AS INTEGER
di AS INTEGER
flags AS INTEGER
ds AS INTEGER
ES AS INTEGER
END TYPE
' Numbers of the assembler routines:
CONST cBlinkStatus = 0
CONST cFillWindow = 1
CONST cGetActiveColor = 2
CONST cGetVideoInfo = 3
CONST cMsDOS = 4
CONST cInterruptX = 5
CONST cLptReady = 6
CONST cMemCopy = 7
CONST cMemScan = 8
CONST cSaveWindow = 9
CONST cRestoreWindow = 10
CONST cSetError = 11
CONST cShift = 12
CONST cToggleBlinkBit = 13
CONST cCmd = 14
CONST cSetCmd = 15
' Logical constants:
CONST TRUE = -1, FALSE = 0
' Numbers of the discerned video cards
' Useful with SUB GetVideoInfo
CONST OTHER = 0, MDA = 1, CGA = 2, EGA = 3, MCGA = 4, VGA = 5, HERC = 11
' Directions
' Useful with SUB Shift
CONST LEFT = 0, RIGHT = 1
' Effect of blink bit of screen color code
' Useful with FUNCTION BlinkStatus and SUB ToggleBlinkBit
CONST BRIGHT = 0, BLINKING = -1
' Declarations of subroutines and functions
DECLARE FUNCTION BlinkStatus ()
DECLARE FUNCTION Cmd$ ()
DECLARE FUNCTION Exch (Integ)
DECLARE FUNCTION GetActiveColor ()
DECLARE FUNCTION GetVideoMode ()
DECLARE FUNCTION Hi (i)
DECLARE FUNCTION IntMax (Int1, Int2)
DECLARE FUNCTION IntMin (Int1, Int2)
DECLARE FUNCTION Lo (i)
DECLARE FUNCTION LptReady (Lpt, Status)
DECLARE FUNCTION MemScan& (Bytes&, SourceSeg, SourceOffs, Search$)
DECLARE FUNCTION PeekString$ (Segment, Offset, Length)
DECLARE FUNCTION PeekWord (Segment, OffSet)
DECLARE FUNCTION SetWord (HiByte, LoByte)
DECLARE SUB Attr (Fore, Back)
DECLARE SUB FillWindow (Top, Left, Bottom, Right, Ascii, Fore, Back)
DECLARE SUB GetAttr (Fore, Back)
DECLARE SUB GetCursorLoc (Row, Column)
DECLARE SUB GetVideoInfo (Video AS VideoType)
DECLARE SUB InterruptX (IntNo, InReg AS RegTypeX, OutReg AS RegTypeX)
DECLARE SUB MSDOS (InReg AS RegTypeX, OutReg AS RegTypeX)
DECLARE SUB MemCopy (Bytes&, FromSeg, FromOffs, ToSeg, ToOffs)
DECLARE SUB PokeWord (Segment, OffSet, Value)
DECLARE SUB RestoreScreen (Buffer())
DECLARE SUB SavePartScreen (Top, Left, Bottom, Right, Buffer())
DECLARE SUB SaveScreen (Buffer())
DECLARE SUB SetCmd (CmdStr$)
DECLARE SUB SetCursorLoc (Row, Column)
DECLARE SUB SetError (ErrorLevel)
DECLARE SUB SetHi (i, HiByte)
DECLARE SUB SetLo (i, LoByte)
DECLARE SUB Shift (Direction, SomeInt, Bits)
DECLARE SUB ToggleBlinkBit (Toggle)
SUB Attr (Fore, Back)
'Replacement for COLOR, especially handy when using bright background
'colors.
'Does NOT use QBASIX.EXE.
SHARED SFore, SBack, AttrBefore
IF NOT AttrBefore THEN
SFore = 7
AttrBefore = TRUE
END IF
IF Fore >= 0 THEN SFore = Fore
IF Back >= 0 THEN SBack = Back
IF SBack AND 8 THEN
f = SFore OR 16
b = SBack XOR 8
ELSE
f = SFore
b = SBack
END IF
COLOR f, b
END SUB
FUNCTION BlinkStatus
'Returns -1 if blinking text is enabled or 0 if it is not.
'Does use QBASIX.EXE.
'For indicating the effect of the blink bit it is handy to use the
'constants BRIGHT and BLINKING defined above, for instance
'IF BlinkStatus = BRIGHT THEN ....
SHARED SegBasix, OffsBasix
DEF SEG = SegBasix
CALL ABSOLUTE(Status, cBlinkStatus, OffsBasix)
BlinkStatus = Status
END FUNCTION
FUNCTION Cmd$
'Passes a command line, set by means of the switch /cmd (as with QB)
'when calling QBASIC, to the program.
'Does use QBASIX.EXE.
SHARED SegBasix, OffsBasix
Temp$ = SPACE$(80)
DEF SEG = SegBasix
CALL ABSOLUTE(Temp$, cCmd, OffsBasix)
Cmd$ = RTRIM$(Temp$)
END FUNCTION
FUNCTION Exch (Integ)
'Exchanges high and low byte of integer.
'Does NOT use QBASIX.EXE.
Ptr1 = VARPTR(Integ)
Ptr2 = VARPTR(Exchange)
DEF SEG
POKE Ptr2, PEEK(Ptr1 + 1)
POKE Ptr2 + 1, PEEK(Ptr1)
Exch2 = Exchange
END FUNCTION
SUB FillWindow (Top, Left, Bottom, Right, Ascii, Fore, Back)
'Colors foreground and/or background of a rectangular text screen
'area and/or fills it with a character.
'Does use QBASIX.EXE.
SHARED SegBasix, OffsBasix
DEF SEG = SegBasix
CALL ABSOLUTE(Top, Left, Bottom, Right, Ascii, Fore, Back, cFillWindow, OffsBasix)
END SUB
FUNCTION GetActiveColor
'Returns the screen color active in DOS.
'Does use QBASIX.EXE.
SHARED SegBasix, OffsBasix
DEF SEG = SegBasix
CALL ABSOLUTE(ActiveColor, cGetActiveColor, OffsBasix)
GetActiveColor = ActiveColor
END FUNCTION
SUB GetAttr (Fore, Back)
'Returns the colors set with the previous call of Attr.
'Meaningful only when using SUB Attr.
'Does NOT use QBASIX.EXE.
SHARED SFore, SBack, AttrBefore
IF NOT AttrBefore THEN
SFore = 7
AttrBefore = TRUE
END IF
Fore = SFore
Back = SBack
END SUB
SUB GetCursorLoc (Row, Column)
'Gets the location of the cursor by way of the BIOS.
'Does use SUB InterruptX and QBASIX.EXE.
DIM Reg AS RegTypeX
Reg.AX = &H300
Reg.BX = 0
InterruptX &H10, Reg, Reg
Row = Reg.DX \ 256 + 1 'from 0 to 1 as a base
Column = Reg.DX MOD 256 + 1
END SUB
SUB GetVideoInfo (Video AS VideoType)
'Returns information about the video configuration.
'Does use TYPE VideoType and QBASIX.EXE.
'It is handy to test for the type of video card with the help of the
'constants VGA, EGA etc., defined above.
SHARED SegBasix, OffsBasix
DEF SEG = SegBasix
CALL ABSOLUTE(Video, cGetVideoInfo, OffsBasix)
END SUB
FUNCTION GetVideoMode
'Returns the active video mode.
'Does use SUB InterruptX and QBASIX.EXE.
DIM Reg AS RegTypeX
Reg.AX = &HF00
InterruptX &H10, Reg, Reg
GetVideoMode = (Reg.AX AND &HFF)
END FUNCTION
FUNCTION Hi(Integ)
'Returns high byte of integer.
'Does NOT use QBASIX.EXE.
DEF SEG
Hi = PEEK(VARPTR(Integ) + 1)
END FUNCTION
SUB InterruptX (IntNo, InReg AS RegTypeX, OutReg AS RegTypeX)
'Executes interrupt.
'Does use TYPE RegTypeX and QBASIX.EXE.
SHARED SegBasix, OffsBasix
DEF SEG = SegBasix
CALL ABSOLUTE(IntNo, InReg, OutReg, cInterruptX, OffsBasix)
END SUB
FUNCTION IntMax(Int1, Int2)
'Returns the maximum of 2 integers
'Does NOT use QBASIX.EXE.
IF Int1 >= Int2 THEN
IntMax = Int1
ELSE
IntMax = Int2
END IF
END FUNCTION
FUNCTION IntMin(Int1, Int2)
'Returns the minimum of 2 integers
'Does NOT use QBASIX.EXE.
IF Int1 <= Int2 THEN
IntMin = Int1
ELSE
IntMin = Int2
END IF
END FUNCTION
FUNCTION Lo(Integ)
'Returns low byte of integer.
'Does NOT use QBASIX.EXE.
Lo = Integ AND 255
END FUNCTION
FUNCTION LptReady (Lpt, Status)
'Determines if printer is ready and passes printer status.
'Does use QBASIX.EXE.
SHARED SegBasix, OffsBasix
DEF SEG = SegBasix
CALL ABSOLUTE(Lpt, Status, Ready, cLptReady, OffsBasix)
LptReady = Ready
END FUNCTION
SUB MemCopy (Bytes&, FromSeg, FromOffs, ToSeg, ToOffs)
'Copies a number of bytes from one memory location to another.
'Does use QBASIX.EXE.
SHARED SegBasix, OffsBasix
DEF SEG = SegBasix
CALL ABSOLUTE(Bytes&, FromSeg, FromOffs, ToSeg, ToOffs, cMemCopy, OffsBasix)
END SUB
FUNCTION MemScan& (Bytes&, SourceSeg, SourceOffs, Search$)
'Scans a memory block of at most 64Kb for a string.
'Does use QBASIX.EXE.
SHARED SegBasix, OffsBasix
DEF SEG = SegBasix
CALL ABSOLUTE(Bytes&, SourceSeg, SourceOffs, Search$, Where&, cMemScan, OffsBasix)
MemScan& = Where&
END FUNCTION
SUB MSDOS (InReg AS RegTypeX, OutReg AS RegTypeX)
'Executes DOS interrupt.
'Does use TYPE RegTypeX and QBASIX.EXE.
SHARED SegBasix, OffsBasix
DEF SEG = SegBasix
CALL ABSOLUTE(InReg, OutReg, cMsDOS, OffsBasix)
END SUB
FUNCTION PeekString$ (Segment, Offset, Length)
'Reads a string of specified length from specified address.
'Does NOT use QBASIX.EXE.
IF Length > 0 THEN
PeekString$ = SPACE$(Length)
DEF SEG = Segment
FOR i = 1 TO Length
MID$(PeekString$, i, 1) = CHR$(PEEK(Offset - 1 + i))
NEXT i
ELSE
PeekString$ = ""
END IF
END FUNCTION
FUNCTION PeekWord (Segment, Offset)
'Reads a word from the specified address.
'Does NOT use QBASIX.EXE.
DEF SEG = Segment
Word = PEEK(Offset)
HiByte = PEEK(Offset + 1)
DEF SEG
POKE VARPTR(Word) + 1, HiByte
PeekWord = Word
END FUNCTION
SUB PokeWord (Segment, Offset, Word)
'Writes a word to the specified address.
'Does NOT use QBASIX.EXE.
DEF SEG
HiByte = PEEK(VARPTR(Word) + 1)
DEF SEG = Segment
POKE Offset, Word
POKE Offset + 1, HiByte
END SUB
SUB RestoreScreen (Buffer())
'Restores rectangular text screen area (window) from buffer array.
'Meaningful only when using SUB SaveScreen or SUB SavePartScreen.
'Does use SUB Attr and QBASIX.EXE.
SHARED SegBasix, OffsBasix
i = LBOUND(Buffer)
IF UBOUND(Buffer) - i < 8 THEN EXIT SUB
DEF SEG = SegBasix
CALL ABSOLUTE(Buffer(i + 4), Buffer(i + 5), Buffer(i + 6), Buffer(i + 7), SEG Buffer(i + 8), cRestoreWindow, OffsBasix)
DEF SEG
LOCATE Buffer(i), Buffer(i + 1)
Attr Buffer(i + 2), Buffer(i + 3)
END SUB
SUB SavePartScreen (Top, Left, Bottom, Right, Buffer())
'Saves screen window with cursor location and color setting in buffer
'array. Meaningful only when using SUB RestoreScreen.
'Does use SUB GetAttr and QBASIX.EXE.
SHARED SegBasix, OffsBasix
'N.B.: valid coordinates are not checked upon.
i = LBOUND(Buffer)
j = i + 7 + (Bottom - Top + 1) * (Right - Left + 1)
IF UBOUND(Buffer) < j THEN
REDIM Buffer(i TO j)
END IF
Buffer(i) = CSRLIN
Buffer(i + 1) = POS(0)
GetAttr Buffer(i + 2), Buffer(i + 3)
Buffer(i + 4) = Top
Buffer(i + 5) = Left
Buffer(i + 6) = Bottom
Buffer(i + 7) = Right
DEF SEG = SegBasix
CALL ABSOLUTE(Top, Left, Bottom, Right, SEG Buffer(i + 8), cSaveWindow, OffsBasix)
END SUB
SUB SaveScreen (Buffer())
'Saves full screen with cursor location and color setting in buffer
'array, taking into account the active video mode.
'Meaningful only when using SUB RestoreScreen.
'Does use SUB GetAttr, SUB GetVideoInfo and QBASIX.EXE.
SHARED SegBasix, OffsBasix
DIM Video AS VideoType
GetVideoInfo Video
i = LBOUND(Buffer)
j = i + 7 + Video.Rows * Video.Cols
IF UBOUND(Buffer) < j THEN
REDIM Buffer(i TO j)
END IF
Buffer(i) = CSRLIN
Buffer(i + 1) = POS(0)
GetAttr Buffer(i + 2), Buffer(i + 3)
Buffer(i + 4) = 1
Buffer(i + 5) = 1
Buffer(i + 6) = Video.Rows
Buffer(i + 7) = Video.Cols
DEF SEG = SegBasix
CALL ABSOLUTE(1, 1, Video.Rows, Video.Cols, SEG Buffer(i + 8), cSaveWindow, OffsBasix)
END SUB
SUB SetCmd (CmdStr$)
'Changes the command line meant for the basic program from inside QBASIC.
'Does use QBASIX.EXE.
SHARED SegBasix, OffsBasix
IF IsQBASIX THEN
DEF SEG = SegBasix
CALL ABSOLUTE(CmdStr$, cSetCmd, OffsBasix)
ELSE
PRINT "Geen opdrachtregel beschikbaar omdat QBASIX niet is geladen."
END IF
END SUB
SUB SetCursorLoc (Row, Column)
'Sets cursor location by way of the BIOS
'Does use SUB InterruptX and QBASIX.EXE.
DIM Reg AS RegTypeX
Reg.AX = &H200
Reg.BX = 0
Reg.DX = (Row - 1) * 256 + (Column - 1) 'from 1 to 0 as a base
InterruptX &H10, Reg, Reg
END SUB
SUB SetError (ErrorLevel)
'Sets termination code (error level) of the program.
'Does use QBASIX.EXE.
SHARED SegBasix, OffsBasix
DEF SEG = SegBasix
CALL ABSOLUTE(ErrorLevel, cSetError, OffsBasix)
END SUB
SUB SetHi (i, HiByte)
'Gives high byte of integer another value.
'Does NOT use QBASIX.EXE.
DEF SEG
POKE VARPTR(i) + 1, HiByte
END SUB
SUB SetLo (i, LoByte)
'Gives low byte of integer another value.
'Does NOT use QBASIX.EXE.
DEF SEG
POKE VARPTR(i), LoByte
END SUB
FUNCTION SetWord (HiByte, LoByte)
'Forms integer from high byte and low byte.
'Does NOT use QBASIX.EXE.
DEF SEG
POKE VARPTR(i) + 1, HiByte
POKE VARPTR(i), LoByte
SetWord = i
END FUNCTION
SUB Shift (Direction, SomeInt, Bits)
'Shifts bits of integer a number of places to the left or the right.
'Does use QBASIX.EXE.
'For indicating the direction in which the bits are to be shifted it
'is convenient to use the constants LEFT and RIGHT defined above.
SHARED SegBasix, OffsBasix
DEF SEG = SegBasix
CALL ABSOLUTE(Direction, SomeInt, Bits, cShift, OffsBasix)
END SUB
SUB ToggleBlinkBit (Toggle)
'Sets the effect of the blink bit of the screen color code to blinking
'text or bright background.
'Does use QBASIX.EXE.
'For indicating the effect of the blink bit it is handy to use the
'constants BRIGHT and BLINKING defined above, for instance
'CALL ToggleBlinkbit (BRIGHT)
SHARED SegBasix, OffsBasix
DEF SEG = SegBasix
CALL ABSOLUTE(Toggle, cToggleBlinkBit, OffsBasix)
END SUB